home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / apps / database / postgres / postgre4.z / postgre4 / src / contrib / pgperl / pg-mus < prev    next >
Encoding:
Text File  |  1992-08-27  |  3.4 KB  |  162 lines
  1. #!/usr/local/bin/perl
  2. # $Header: /private/postgres/src/contrib/pgperl/RCS/pg-mus,v 1.2 1991/03/08 13:22:34 kemnitz Exp $
  3. # This perl-script take a "mus" file and converts it to C.
  4. # Written by Larry Wall (?).
  5. # Adapted for use with Postgres by Igor Metz <metz@iam.unibe.ch>
  6.  
  7. # $Id: pg-mus,v 1.2 1991/03/08 13:22:34 kemnitz Exp $
  8. # $Log: pg-mus,v $
  9. # Revision 1.2  1991/03/08  13:22:34  kemnitz
  10. # added RCS header.
  11. #
  12. # Revision 1.1  90/10/24  20:31:14  cimarron
  13. # Initial revision
  14. # 
  15. # Revision 1.2  90/08/23  14:17:39  metz
  16. # o comments added
  17. # 
  18. # Revision 1.1  90/08/23  11:41:19  metz
  19. # Initial revision
  20. # 
  21.  
  22. while (<>) {
  23.     if (s/^CASE\s+//) {
  24.     @fields = split;
  25.     $funcname = pop(@fields);
  26.     $rettype = "@fields";
  27.     @modes = ();
  28.     @types = ();
  29.     @names = ();
  30.     @outies = ();
  31.     @callnames = ();
  32.     $pre = "\n";
  33.     $post = '';
  34.  
  35.     while (<>) {
  36.         last unless /^[IO]+\s/;
  37.         @fields = split(' ');
  38.         push(@modes, shift(@fields));
  39.         push(@names, pop(@fields));
  40.         push(@types, "@fields");
  41.     }
  42.     while (s/^<\s//) {
  43.         $pre .= "\t    $_";
  44.         $_ = <>;
  45.     }
  46.     while (s/^>\s//) {
  47.         $post .= "\t    $_";
  48.         $_ = <>;
  49.     }
  50.     $items = @names;
  51.     $namelist = '$' . join(', $', @names);
  52.     $namelist = '' if $namelist eq '$';
  53.     print <<EOF;
  54.     case US_$funcname:
  55.     if (items != $items)
  56.         fatal("Usage: &$funcname($namelist)");
  57.     else {
  58. EOF
  59.     if ($rettype eq 'void') {
  60.         print <<EOF;
  61.         /* int retval = 1; */
  62. EOF
  63.     }
  64.     else {
  65.         print <<EOF;
  66.         $rettype retval;
  67. EOF
  68.     }
  69.     foreach $i (1..@names) {
  70.         $mode = $modes[$i-1];
  71.         $type = $types[$i-1];
  72.         $name = $names[$i-1];
  73.         $what = ($type =~ /^(struct\s+\w+|char|\w+)\s*\*$/ ? "get" : "gnum");
  74.         $type .= "\t" if length($type) < 4;
  75.         $cast .= "\t" if length($cast) < 8;
  76.         $x = "\t" x (length($name) < 6);
  77.         if ($mode =~ /O/) {
  78.         if ($what eq 'gnum') {
  79.             push(@outies, "\t    str_numset(st[$i], (double) $name);\n");
  80.         }
  81.         else {
  82.             push(@outies, "\t    str_set(st[$i], (char*) $name);\n");
  83.         }
  84.         push(@callnames, "&$name");
  85.         }
  86.         else {
  87.         push(@callnames, $name);
  88.         }
  89.         if ($mode =~ /I/) {
  90.             if ($type =~ /^char\*$/) {
  91.               # no special handling necessary
  92.           print <<EOF;
  93.         $type    $name =$x    str_get(st[$i]);
  94. EOF
  95.           }
  96.           elsif ($type =~ /^\w+\*$/) {
  97.           print <<EOF;
  98.         $type    $name =$x ($type) dbl2uint(str_gnum(st[$i]));
  99. EOF
  100.           }
  101.           else {
  102.           print <<EOF;
  103.         $type    $name =$x ($type) dbl2uint(str_gnum(st[$i]));
  104. EOF
  105.           }
  106.            }
  107.     }
  108.     $callnames = join(', ', @callnames);
  109.     $outies = join("\n",@outies);
  110.     if ($rettype eq 'void') {
  111.         print <<EOF;
  112. $pre        (void)$funcname($callnames);
  113. EOF
  114.     }
  115.     else {
  116.         print <<EOF;
  117. $pre        retval = $funcname($callnames);
  118. EOF
  119.     }
  120.  
  121.     if ($rettype =~ /^char\s*\*$/) {  # char*
  122.         print <<EOF;
  123.         str_set(st[0], retval);
  124. EOF
  125.         }
  126.     elsif ($rettype =~ /^\s*void\s*$/) { # void
  127.         print <<EOF;
  128.         str_numset(st[0], 1.0);
  129. EOF
  130.     }
  131.     elsif ($rettype =~ /^\w+\s*\*+$/) { # anyothertype*
  132.         print <<EOF;
  133.         str_numset(st[0],  uint2dbl((unsigned int) retval));
  134. EOF
  135.         }
  136.     elsif ($rettype =~ /^(char|short|int|unsigned\s+int|signed\s+int)$/) {
  137.         print <<EOF;
  138.         str_numset(st[0],  uint2dbl((unsigned int) retval));
  139. EOF
  140.     }
  141.     else { # ($rettype =~ /^\w+\s*$/) 
  142.         print <<EOF;
  143.         str_nset(st[0], (char*) &retval, sizeof(retval));
  144. EOF
  145.     }
  146.     print $outies if $outies;
  147.     print $post if $post;
  148.     if (/^END/) {
  149.         print "\t}\n\treturn sp;\n";
  150.     }
  151.     else {
  152.         redo;
  153.     }
  154.     }
  155.     elsif (/^END/) {
  156.     print "\t}\n\treturn sp;\n";
  157.     }
  158.     else {
  159.     print;
  160.     }
  161. }
  162.